﻿/// A CSS Creator is similar to a CSS Selector, but used to
/// create HTML elements rather than find them.
module WingBeats.Xml.CreatorParser

open FParsec.Primitives
open FParsec.CharParsers
open WingBeats.Xml

type CreatorParseException(message:string, ?inner:exn) =
    inherit exn (message, match inner with | Some(ex) -> ex | None -> null)

type CreatorPart =
    | Tag         of string
    | Id          of string
    | Classes     of string list
    | Attributes  of (string * string) list
    | Placeholder of string
    | Repeat      of int

and Combinator =
    | Child         // >
    | Sibling       // + or ,
    //| ParentSibling // < for moving back up the hierarchy
    // descendant, indirect-adjacent not relevant to element creation

and CssCreator =
    | Creator   of CreatorPart list
    | Connector of Combinator

type private Parser<'a> = Parser<'a,unit>

let private ch c = skipChar c
let private str s = skipString s >>. spaces

let private isAlphaNum c = isLetter c || isDigit c || c = '_' || c = '-'
let private ident = many1SatisfyL isAlphaNum "identifier"

// From Stephan:
// note: I'll soon push a fast and flexible identifier parser to the BitBucket
//       repository (which will be able to parse and validate the XID syntax
//       from the Unicode Standard Annex #31 )

let private tagName =
    many1SatisfyL (fun c -> isLetter c || isDigit c || c = '|') "tag name"
    |>> Tag

let private placeHolder =
    ch '$' >>. (ident |>> Placeholder)
             // note: the parens here slightly improve performane
             // in case the parser does not encounter '$'

let private classNames =
    ch '.' >>. (sepBy1 ident (ch '.') |>> Classes)

let private idString =
    ch '#' >>. (ident |>> Id)

let private betweenQuotes p =
    between (ch '\'') (ch '\'') p <|> between (ch '"') (ch '"') p

let private attribute =
    let isWhitespaceOrPunctuation =
        isAnyOf "\r\n \t:%&#/\\.,_-()" // creates a predicate function
    let isAttrVal c = isLetter c || isDigit c || isWhitespaceOrPunctuation c
    let unquoted = many1Satisfy isAttrVal
    let quoted = betweenQuotes (many1Satisfy (fun c -> isAttrVal c || c = ';'))
    let value = choiceL [|quoted; unquoted|] "attribute value"

    spaces >>. tuple2 ident (ch '=' >>. value)

let private attributes =
    between (ch '[') (ch ']')
            (sepBy1 attribute (ch ';') |>> Attributes)

let private repeat =
    ch '*' >>. pint32 |>> Repeat

let private singleCreator =
    let parts = choice [|idString; classNames; attributes; placeHolder; repeat|]

    pipe2 tagName (many parts) (fun name props -> Creator(name::props))
    <|> (many1 parts |>> Creator) // no tag name


let private tagAttributes =
    let parts = idString <|> classNames <|> attributes
    spaces >>. (many1 parts) .>> spaces

let private combinators =
    let combinatorChar =
        satisfyL (function '>'|'+'|',' (*|'<'*) -> true | _ -> false)
                 "combinator char ('>', '+' or ',')"

    spaces >>. combinatorChar .>> spaces
    |>> function
        | '>'       -> Connector(Child)
        | '+' | ',' -> Connector(Sibling)
      //| '<'       -> Connector(ParentSibling)
        |  _        -> failwith "combinators"

let private manyCreators =
    let flatten = List.collect (fun (x,y) -> [x;y])
    let parts = pipe2 (opt singleCreator) (many (tuple2 combinators singleCreator))
                      (fun optFirstItem sepItemPairs ->
                           match optFirstItem with
                           | Some(item) -> item :: flatten sepItemPairs
                           | None       -> flatten sepItemPairs)

    spaces >>. parts .>> (spaces .>> eof)

/// Parses a CSS Creator string, which may define a multiple-tag hierarchy.
let parseCreator s =
    match run manyCreators s with
    | Failure(msg,_,_)   -> raise <| CreatorParseException(msg)
    | Success(props,_,_) -> props

/// Parses the attributes of a single tag.
/// Doesn't support placeholders, repeats, or child/sibling tags.
let parseAttributes s =
    match run tagAttributes s with
    | Failure(msg,_,_)   -> raise <| CreatorParseException(msg)
    | Success(props,_,_) -> props

